home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / initTcl.tcl < prev    next >
Encoding:
Text File  |  2000-11-18  |  25.3 KB  |  865 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # SCCS: @(#) init.tcl 1.86 97/08/08 10:37:39
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  10. # Some additions copyright (c) 1997-2000 Vince Darley.
  11.  
  12. set errorCode ""
  13. set errorInfo ""
  14.  
  15. if {[info commands tclLog] == ""} {
  16.     proc tclLog {string} {
  17.     message [string trim $string "\r"]
  18.     }
  19. }
  20. if {[info tclversion] >= 8.0} {
  21.     namespace eval index {}
  22.     namespace eval procs {}
  23.     # used to force some child namespaces into existence
  24.     ;proc namesp {var} {
  25.     if {[catch "uplevel global $var"]} {
  26.         set ns ""
  27.         while {[regexp "^(::)?($ns\[a-zA-Z_\]+::)" $var ns]} {
  28.         uplevel "namespace eval $ns {}"
  29.         }
  30.     }
  31.     }
  32. } else {
  33.     ;proc namesp {var} {}
  34.     rename load evaluate
  35. }
  36.  
  37. # 7.1 doesn't rename unbind in the actual application
  38. if {[info commands unBind] == ""} { 
  39.     if {[info commands unbind] != ""} {rename unbind unBind}
  40. }
  41.  
  42. # define compatibility procs for menu, bind, unbind
  43. if {[info commands bind] == ""} {
  44.     proc bind {args} { uplevel 1 Bind $args }
  45.     proc unbind {args} { uplevel 1 unBind $args }
  46.     proc menu {args} { 
  47.     regsub -all "\{menu " $args "\{Menu " args
  48.     uplevel 1 Menu $args 
  49.     }
  50. }
  51. namespace eval file {}
  52. # determine platform specific directory symbol
  53. regexp {Z(.)Z} [file join Z Z] "" file::separator
  54. # To get rid of the stupid {} variable created by the above line.
  55. # We 'catch' in case a future version of Tcl fixes this silliness.
  56. catch {unset {}}
  57.  
  58. proc catchNoClobber {script args} {
  59.     global errorCode errorInfo
  60.     set oldErrorCode $errorCode
  61.     set oldErrorInfo $errorInfo
  62.     if {[set ret [uplevel 1 [list catch $script] $args]]} {
  63.     set errorCode $oldErrorCode
  64.     set errorInfo $oldErrorInfo
  65.     return $ret
  66.     } else {
  67.     return 0
  68.     }
  69. }
  70.  
  71. # Note: if this DOES exist (e.g. in Alphatk, and possibly Alpha 8),
  72. # then procs like auto_load must already exist, and have been loaded
  73. # in from Tcl's core library routines.
  74. if {![info exists useStandardTclIndices]} {
  75. ## 
  76.  # -------------------------------------------------------------------------
  77.  # 
  78.  # "unknown" --
  79.  # 
  80.  #  Almost the same as standard Tcl 8 unknown.  Since we're on a Mac,
  81.  #  I removed the auto_execok flag, and for some reason had to change
  82.  #  'history change $newcmd 0' to 'history change $newcmd'
  83.  # -------------------------------------------------------------------------
  84.  ##
  85. # unknown --
  86. # This procedure is called when a Tcl command is invoked that doesn't
  87. # exist in the interpreter.  It takes the following steps to make the
  88. # command available:
  89. #
  90. #    1. See if the autoload facility can locate the command in a
  91. #       Tcl script file.  If so, load it and execute it.
  92. #    2. If the command was invoked interactively at top-level:
  93. #        (a) see if the command exists as an executable UNIX program.
  94. #        If so, "exec" the command.
  95. #        (b) see if the command requests csh-like history substitution
  96. #        in one of the common forms !!, !<number>, or ^old^new.  If
  97. #        so, emulate csh's history substitution.
  98. #        (c) see if the command is a unique abbreviation for another
  99. #        command.  If so, invoke the command.
  100. #
  101. # Arguments:
  102. # args -    A list whose elements are the words of the original
  103. #        command, including the command name.
  104. proc unknown args {
  105.     global auto_noload env unknown_pending tcl_interactive
  106.     global errorCode errorInfo
  107.     
  108.     # Save the values of errorCode and errorInfo variables, since they
  109.     # may get modified if caught errors occur below.  The variables will
  110.     # be restored just before re-executing the missing command.
  111.     
  112.     set savedErrorCode $errorCode
  113.     set savedErrorInfo $errorInfo
  114.     set name [lindex $args 0]
  115.     if {![info exists auto_noload]} {
  116.     #
  117.     # Make sure we're not trying to load the same proc twice.
  118.     #
  119.     if {[info exists unknown_pending($name)]} {
  120.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  121.     }
  122.     set unknown_pending($name) pending;
  123.     set ret [catch {auto_load $name} msg]
  124.     unset unknown_pending($name);
  125.     if {$ret != 0} {
  126.         return -code $ret -errorcode $errorCode \
  127.           "error while autoloading \"$name\": $msg"
  128.     }
  129.     if {![array size unknown_pending]} {
  130.         unset unknown_pending
  131.     }
  132.     if {$msg} {
  133.         set errorCode $savedErrorCode
  134.         set errorInfo $savedErrorInfo
  135.         set code [catch {uplevel 1 $args} msg]
  136.         if {$code ==  1} {
  137.         #
  138.         # Strip the last five lines off the error stack (they're
  139.         # from the "uplevel" command).
  140.         #
  141.         
  142.         set new [split $errorInfo \n]
  143.         set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
  144.         return -code error -errorcode $errorCode \
  145.           -errorinfo $new $msg
  146.         } else {
  147.         return -code $code $msg
  148.         }
  149.     }
  150.     }
  151.     if {([info level] == 1) && ([info script] == "") \
  152.       && [info exists tcl_interactive] && $tcl_interactive} {
  153.     set errorCode $savedErrorCode
  154.     set errorInfo $savedErrorInfo
  155.     if {$name == "!!"} {
  156.         set newcmd [history event]
  157.     } elseif {[regexp {^!(.+)$} $name dummy event]} {
  158.         set newcmd [history event $event]
  159.     } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
  160.         set newcmd [history event -1]
  161.         catch {regsub -all -- $old $newcmd $new newcmd}
  162.     }
  163.     if {[info exists newcmd]} {
  164.         tclLog "\r$newcmd"
  165.         history change $newcmd
  166.         return [uplevel $newcmd]
  167.     }
  168.     
  169.     set ret [catch {set cmds [info commands $name*]} msg]
  170.     if {[string compare $name "::"] == 0} {
  171.         set name ""
  172.     }
  173.     if {$ret != 0} {
  174.         return -code $ret -errorcode $errorCode \
  175.           "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
  176.     }
  177.     if {[llength $cmds] == 1} {
  178.         return [uplevel [lreplace $args 0 0 $cmds]]
  179.     }
  180.     if {[llength $cmds] != 0} {
  181.         if {$name == ""} {
  182.         return -code error "empty command name \"\""
  183.         } else {
  184.         return -code error \
  185.           "ambiguous command name \"$name\": [lsort $cmds]"
  186.         }
  187.     }
  188.     }
  189.     return -code error "invalid command name \"$name\""
  190. }
  191.  
  192. ## 
  193.  # -------------------------------------------------------------------------
  194.  # 
  195.  # "auto_load" --
  196.  # 
  197.  #  I use this separate proc to be closer to the standard Tcl 8 system
  198.  #  of unknown-loading.
  199.  # -------------------------------------------------------------------------
  200.  ##
  201. proc auto_load cmd {
  202.     set f [procs::find $cmd]
  203.     if {$f != ""} {
  204.     uplevel \#0 source [list $f]
  205.     return [expr {[llength [info commands $cmd]] != 0}]
  206.     }
  207.     if {[regsub {^::} $cmd "" cmd]} {
  208.     set f [procs::find $cmd]
  209.     if {$f != ""} {
  210.         uplevel \#0 source [list $f]
  211.         return [expr {[llength [info commands $cmd]] != 0}]
  212.     }
  213.     }
  214.     # to cope with some Tcl 8 package stuff
  215.     if {[info tclversion] < 8.0} {
  216.     return 0
  217.     }
  218.     global auto_index auto_oldpath auto_path
  219.  
  220.     set namespace [uplevel {namespace current}]
  221.     set nameList [auto_qualify $cmd $namespace]
  222.     # workaround non canonical auto_index entries that might be around
  223.     # from older auto_mkindex versions
  224.     lappend nameList $cmd
  225.     foreach name $nameList {
  226.     if {[info exists auto_index($name)]} {
  227.         uplevel #0 $auto_index($name)
  228.         return [expr {[info commands $name] != ""}]
  229.     }
  230.     }
  231.     if {![info exists auto_path]} {
  232.     return 0
  233.     }
  234.  
  235.     if {![auto_load_index]} {
  236.     return 0
  237.     }
  238.  
  239.     foreach name $nameList {
  240.     if {[info exists auto_index($name)]} {
  241.         uplevel #0 $auto_index($name)
  242.         if {[info commands $name] != ""} {
  243.         return 1
  244.         }
  245.     }
  246.     }
  247.     return 0
  248. }
  249.  
  250. # auto_load_index --
  251. # Loads the contents of tclIndex files on the auto_path directory
  252. # list.  This is usually invoked within auto_load to load the index
  253. # of available commands.  Returns 1 if the index is loaded, and 0 if
  254. # the index is already loaded and up to date.
  255. #
  256. # Arguments: 
  257. # None.
  258.  
  259. proc auto_load_index {} {
  260.     global auto_index auto_oldpath auto_path errorInfo errorCode
  261.  
  262.     if {[info exists auto_oldpath]} {
  263.     if {$auto_oldpath == $auto_path} {
  264.         return 0
  265.     }
  266.     }
  267.     set auto_oldpath $auto_path
  268.  
  269.     # Check if we are a safe interpreter. In that case, we support only
  270.     # newer format tclIndex files.
  271.  
  272.     set issafe [interp issafe]
  273.     for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
  274.     set dir [lindex $auto_path $i]
  275.     set f ""
  276.     if {$issafe} {
  277.         catch {source [file join $dir tclIndex]}
  278.     } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
  279.         continue
  280.     } else {
  281.         set error [catch {
  282.         set id [gets $f]
  283.         if {$id == "# Tcl autoload index file, version 2.0"} {
  284.             eval [read $f]
  285.         } elseif {$id == \
  286.             "# Tcl autoload index file: each line identifies a Tcl"} {
  287.             while {[gets $f line] >= 0} {
  288.             if {([string index $line 0] == "#")
  289.                 || ([llength $line] != 2)} {
  290.                 continue
  291.             }
  292.             set name [lindex $line 0]
  293.             set auto_index($name) \
  294.                 "source [file join $dir [lindex $line 1]]"
  295.             }
  296.         } else {
  297.             error \
  298.               "[file join $dir tclIndex] isn't a proper Tcl index file"
  299.         }
  300.         } msg]
  301.         if {$f != ""} {
  302.         close $f
  303.         }
  304.         if {$error} {
  305.         error $msg $errorInfo $errorCode
  306.         }
  307.     }
  308.     }
  309.     return 1
  310. }
  311.  
  312. # auto_qualify --
  313. #
  314. # Compute a fully qualified names list for use in the auto_index array.
  315. # For historical reasons, commands in the global namespace do not have leading
  316. # :: in the index key. The list has two elements when the command name is
  317. # relative (no leading ::) and the namespace is not the global one. Otherwise
  318. # only one name is returned (and searched in the auto_index).
  319. #
  320. # Arguments -
  321. # cmd        The command name. Can be any name accepted for command
  322. #               invocations (Like "foo::::bar").
  323. # namespace    The namespace where the command is being used - must be
  324. #               a canonical namespace as returned by [namespace current]
  325. #               for instance.
  326.  
  327. proc auto_qualify {cmd namespace} {
  328.  
  329.     # count separators and clean them up
  330.     # (making sure that foo:::::bar will be treated as foo::bar)
  331.     set n [regsub -all {::+} $cmd :: cmd]
  332.  
  333.     # Ignore namespace if the name starts with ::
  334.     # Handle special case of only leading ::
  335.  
  336.     # Before each return case we give an example of which category it is
  337.     # with the following form :
  338.     # ( inputCmd, inputNameSpace) -> output
  339.  
  340.     if {[regexp {^::(.*)$} $cmd x tail]} {
  341.     if {$n > 1} {
  342.         # ( ::foo::bar , * ) -> ::foo::bar
  343.         return [list $cmd]
  344.     } else {
  345.         # ( ::global , * ) -> global
  346.         return [list $tail]
  347.     }
  348.     }
  349.     
  350.     # Potentially returning 2 elements to try  :
  351.     # (if the current namespace is not the global one)
  352.  
  353.     if {$n == 0} {
  354.     if {[string compare $namespace ::] == 0} {
  355.         # ( nocolons , :: ) -> nocolons
  356.         return [list $cmd]
  357.     } else {
  358.         # ( nocolons , ::sub ) -> ::sub::nocolons nocolons
  359.         return [list ${namespace}::$cmd $cmd]
  360.     }
  361.     } else {
  362.     if {[string compare $namespace ::] == 0} {
  363.         #  ( foo::bar , :: ) -> ::foo::bar
  364.         return [list ::$cmd]
  365.     } else {
  366.         # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
  367.         return [list ${namespace}::$cmd ::$cmd]
  368.     }
  369.     }
  370. }
  371.  
  372. # auto_mkindex:
  373. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  374. # the name of the directory in which the tclIndex file is to be placed,
  375. # and a glob pattern to use in that directory to locate all of the relevant
  376. # files.
  377. proc auto_mkindex {dir {files *.tcl}} {
  378.     # Due to some peculiarities with current working directories
  379.     # under some MacOS/HFS+/other conditions, we avoid using
  380.     # 'cd' and 'pwd' explicitly if possible.
  381.     set dir [file nativename $dir]
  382.     global tcl_platform
  383.     switch -- $tcl_platform(platform) {
  384.     "macintosh" {
  385.         if {$dir == ":" || $dir == "."} {
  386.         set dir [pwd]
  387.         }
  388.     }
  389.     default {
  390.         if {$dir == "."} {
  391.         set dir [pwd]
  392.         }
  393.     }
  394.     }
  395.     # So we can handle relative path names
  396.     if {[file pathtype $dir] == "relative"} {
  397.     set dir [file join [pwd] $dir]
  398.     }
  399.     if {[info tclversion] < 8.0} {
  400.     if {![catchNoClobber {file readlink $dir} _root]} {
  401.         set dir $_root
  402.     }
  403.     } else {
  404.     if {[file type $dir] == "link"} {
  405.         set dir [file readlink $dir]
  406.     }
  407.     }
  408.     set dir [string trim $dir :]
  409.     append line "# Tcl autoload index file: each line\
  410.       identifies a file (nowrap)\n\n"
  411.     set indexvar "[file tail [string trim $dir :]]_index"
  412.     append line "set \"${indexvar}\" \{\n"
  413.     
  414.     set cid [scancontext create]
  415.     # This pattern is used to extract procedures when the 'scanfile'
  416.     # command is used below.  We don't do anything too dramatic if
  417.     # the procedure name can't be extracted.  The most likely cause
  418.     # is a garbled file.
  419.     scanmatch $cid "^\[ \t\]*proc\[ \t\]" {
  420.     if {[regexp "^\[ \t\]*proc\[ \t\]+((\"\[^\"\]+\")|(\{\[^\}\]+\})|(\[^ \t\]*))" \
  421.       $matchInfo(line) match procName]} {
  422.         append line "$procName "
  423.     } else {
  424.         message "Couldn't extract a proc from '$matchInfo(line)'!"
  425.     }
  426.     }
  427.     foreach file [glob -dir $dir -- $files] {
  428.     watchCursor
  429.     set f ""
  430.     append line "\{[file tail $file]\14 "
  431.     message [file tail $file]
  432.     if {[catch {open $file r} fid]} {
  433.         lappend errors $fid
  434.         lappend errorFiles $file
  435.     } else {
  436.         if {[catch {scanfile $cid $fid} err]} {
  437.         lappend errors $err
  438.         lappend errorFiles $file
  439.         }
  440.         close $fid
  441.     }
  442.     append line "\}\n"
  443.     }
  444.     
  445.     scancontext delete $cid
  446.     
  447.     append line "\}\n"
  448.     if {[info exists errors]} {
  449.     if {[dialog::yesno -y "View the error" -n "Continue" \
  450.       "The following files: [join $errorFiles ,] were unable\
  451.       to be opened or scanned for procedures to store in Tcl index\
  452.       files.  This is a serious error.  Alpha will not be\
  453.       able to find procedures stored in those files, and will\
  454.       therefore fail to function correctly.  You should\
  455.       ascertain the cause of these\
  456.       problems and fix them.  Your disk may be damaged.\r\
  457.       To avoid some of these problems, the Tcl index file\
  458.       in $dir will not be replaced."]} {
  459.         dialog::alert [join $errors "\r"]
  460.     }
  461.     } else {
  462.     if {[catch {open [file join $dir tclIndexx] w} fid]} {
  463.         if {[file exists [file join $dir tclIndex]] \
  464.           && ![file writable $dir]} {
  465.         # This is a read-only directory, so there isn't
  466.         # a problem that we couldn't write to it.  Probably
  467.         # it's a system directory such as the base Tcl library.
  468.         message "'$dir' is read-only, so I'll use the existing Tcl index."
  469.         } else {
  470.         dialog::alert "The Tcl index file in $dir could not\
  471.           be rewritten.  Perhaps the file is locked or read-only?\
  472.           The old index will be left intact, but you should fix\
  473.           this problem so Alpha can index new files in\
  474.           this directory."
  475.         }
  476.     } else {
  477.         if {[catch {puts -nonewline $fid $line} err]} {
  478.         if {[dialog::yesno -y "View the error" -n "Continue" \
  479.           "The Tcl index file in $dir was successfully opened,\
  480.           but Alpha encountered an error while writing to the\
  481.           file.  This is a very serious problem, and Alpha will\
  482.           probably no longer function correctly.  At the very\
  483.           least you will need to reinstall that directory, and\
  484.           perhaps all of Alpha."]} {
  485.             dialog::alert $err
  486.         }
  487.         }
  488.         catch {close $fid}
  489.     }
  490.     foreach i [info vars $indexvar] {
  491.         global $i
  492.         unset $i
  493.     }
  494.     }
  495.     
  496. }
  497.  
  498. ## 
  499.  # -------------------------------------------------------------------------
  500.  # 
  501.  # "auto_reset" --
  502.  # 
  503.  #  After rebuilding indices, Tcl retains its old index information unless
  504.  #  we tell it not to.
  505.  # -------------------------------------------------------------------------
  506.  ##
  507. proc auto_reset {} {
  508.     global auto_path
  509.     foreach path $auto_path {
  510.     if {![file exists $path]} continue
  511.     set index "[file tail $path]_index"
  512.     global $index
  513.     catch {unset $index}
  514.     }
  515. }
  516.  
  517. proc procs::find {cmd} {
  518.     global auto_path
  519.     regsub -all {[][\$?^|*+()\{\}]} $cmd {\\&} cmd
  520.     foreach path $auto_path {
  521.     if {![file exists $path]} continue
  522.     if {[info tclversion] < 8.0} {
  523.         if {![catchNoClobber {file readlink $path} _path]} {
  524.         set path $_path
  525.         }
  526.     } else {
  527.         if {[file type $path] == "link"} {
  528.         if {[catchNoClobber {set path [file readlink $path]}]} {
  529.             # forget about this one
  530.             continue
  531.         }
  532.         }
  533.     }
  534.     set index "[file tail $path]_index"
  535.     global $index
  536.     if {![info exists $index]} {
  537.         if {![file exists [file join $path tclIndexx]]} continue
  538.         if {[catch [list uplevel \#0 source [list [file join $path tclIndexx]]] err]} {
  539.         alertnote "Tcl index in $path is corrupt.  It throws an error: $err"
  540.         } else {
  541.         if {![info exists $index]} {
  542.             alertnote "Tcl index in $path is incorrectly formed.  It\
  543.               should set the variable $index but doesn't.  You should\
  544.               fix this problem."
  545.         }
  546.         }
  547.     }
  548.     if {[info exists $index]} {
  549.         if {[regexp "\n\{(\[^\14\]+)\14\[^\n\]* \[\"\{\]?(::)?${cmd}\[\"\}\]? " [set $index] dummy file]} {
  550.         return [file join $path $file]
  551.         }
  552.     }
  553.     }
  554.     return ""
  555. }
  556.  
  557. } else {
  558.     # If we're using standard Tcl indices
  559.     proc procs::find {cmd} {
  560.     set entry [uplevel 1 [list findIndexEntry $cmd]]
  561.     if {[string length $entry]} {
  562.         return [lindex $entry 1]
  563.     }
  564.     return ""
  565.     }
  566.  
  567.     # Basically the same as 'auto_load', but doesn't load the
  568.     # command, instead it returns the index entry which should
  569.     # be used.
  570.     proc findIndexEntry {cmd {namespace ""}} {
  571.     global auto_index auto_oldpath auto_path
  572.  
  573.     if {[string length $namespace] == 0} {
  574.         set namespace [uplevel {namespace current}]
  575.     }
  576.     set nameList [auto_qualify $cmd $namespace]
  577.     # workaround non canonical auto_index entries that might be around
  578.     # from older auto_mkindex versions
  579.     lappend nameList $cmd
  580.     foreach name $nameList {
  581.         if {[info exists auto_index($name)]} {
  582.         return $auto_index($name)
  583.         }
  584.     }
  585.     if {![info exists auto_path]} {
  586.         return 0
  587.     }
  588.  
  589.     if {![auto_load_index]} {
  590.         return 0
  591.     }
  592.  
  593.     foreach name $nameList {
  594.         if {[info exists auto_index($name)]} {
  595.         return $auto_index($name)
  596.         }
  597.     }
  598.     return ""
  599.     }
  600.     
  601.     # We do not want to have auto_reset destroy the core Alphatk procedures,
  602.     # so we use this modified version.
  603.     proc auto_reset {} {
  604.     global auto_execs auto_index auto_oldpath
  605.     catch {unset auto_execs}
  606.     catch {unset auto_index}
  607.     catch {unset auto_oldpath}
  608.     }
  609.  
  610.     # auto_mkindex:
  611.     # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  612.     # the name of the directory in which the tclIndex file is to be placed,
  613.     # and a glob pattern to use in that directory to locate all of the relevant
  614.     # files.  For Alpha's core files we cannot use the standard Tcl 8
  615.     # 'auto_mkindex' because it sources the files in question, and many of
  616.     # Alpha's files have nasty side-effects when sourced (e.g. AlphaBits.tcl!)
  617.     #
  618.     # We could look into using 'auto_mkindex_old', but this version here provides
  619.     # much better error reporting...
  620.     proc auto_mkindex {dir {files *.tcl}} {
  621.     # Due to some peculiarities with current working directories
  622.     # under some MacOS/HFS+/other conditions, we avoid using
  623.     # 'cd' and 'pwd' explicitly if possible.
  624.     set dir [file nativename $dir]
  625.     global tcl_platform
  626.     switch -- $tcl_platform(platform) {
  627.         "macintosh" {
  628.         if {$dir == ":" || $dir == "."} {
  629.             set dir [pwd]
  630.         }
  631.         }
  632.         default {
  633.         if {$dir == "."} {
  634.             set dir [pwd]
  635.         }
  636.         }
  637.     }
  638.     # So we can handle relative path names
  639.     if {[file pathtype $dir] == "relative"} {
  640.         set dir [file join [pwd] $dir]
  641.     }
  642.     if {![catchNoClobber {file readlink $dir} _root]} {
  643.         set dir $_root
  644.     }
  645.     set dir [string trim $dir :]
  646.     # This line is very important, or Tcl will reject the file...
  647.     append index "# Tcl autoload index file, version 2.0\n"
  648.     
  649.     set cid [scancontext create]
  650.     # This pattern is used to extract procedures when the 'scanfile'
  651.     # command is used below.  We don't do anything too dramatic if
  652.     # the procedure name can't be extracted.  The most likely cause
  653.     # is a garbled file.
  654.     scanmatch $cid "^\[ \t\]*proc\[ \t\]" {
  655.         if {[regexp "^\[ \t\]*proc\[ \t\]+((\"\[^\"\]+\")|(\{\[^\}\]+\})|(\[^ \t\]*))" \
  656.           $matchInfo(line) match procName]} {
  657.         set procName [lindex [auto_qualify $procName "::"] 0]
  658.         append index "set [list auto_index($procName)]"
  659.         append index " \[list source \[file join \$dir [list [file tail $file]]\]\]\n"
  660.         } else {
  661.         message "Couldn't extract a proc from '$matchInfo(line)'!"
  662.         }
  663.     }
  664.     foreach file [glob -dir $dir -- $files] {
  665.         watchCursor
  666.         set f ""
  667.         message [file tail $file]
  668.         if {[catch {open $file r} fid]} {
  669.         lappend errors $fid
  670.         lappend errorFiles $file
  671.         } else {
  672.         if {[catch {scanfile $cid $fid} err]} {
  673.             lappend errors $err
  674.             lappend errorFiles $file
  675.         }
  676.         close $fid
  677.         }
  678.     }
  679.     
  680.     scancontext delete $cid
  681.     
  682.     if {[info exists errors]} {
  683.         if {[dialog::yesno -y "View the error" -n "Continue" \
  684.           "The following files: [join $errorFiles ,] were unable\
  685.           to be opened or scanned for procedures to store in Tcl index\
  686.           files.  This is a serious error.  Alpha will not be\
  687.           able to find procedures stored in those files, and will\
  688.           therefore fail to function correctly.  You should\
  689.           ascertain the cause of these\
  690.           problems and fix them.  Your disk may be damaged.\r\
  691.           To avoid some of these problems, the Tcl index file\
  692.           in $dir will not be replaced."]} {
  693.         dialog::alert [join $errors "\r"]
  694.         }
  695.     } else {
  696.         if {[catch {open [file join $dir tclIndex] w} fid]} {
  697.         if {[file exists [file join $dir tclIndex]] \
  698.           && ![file writable $dir]} {
  699.             # This is a read-only directory, so there isn't
  700.             # a problem that we couldn't write to it.  Probably
  701.             # it's a system directory such as the base Tcl library.
  702.             message "'$dir' is read-only, so I'll use the existing Tcl index."
  703.         } else {
  704.             dialog::alert "The Tcl index file in $dir could not\
  705.               be rewritten.  Perhaps the file is locked or read-only?\
  706.               The old index will be left intact, but you should fix\
  707.               this problem so Alpha can index new files in\
  708.               this directory."
  709.         }
  710.         } else {
  711.         if {[catch {puts -nonewline $fid $index} err]} {
  712.             if {[dialog::yesno -y "View the error" -n "Continue" \
  713.               "The Tcl index file in $dir was successfully opened,\
  714.               but Alpha encountered an error while writing to the\
  715.               file.  This is a very serious problem, and Alpha will\
  716.               probably no longer function correctly.  At the very\
  717.               least you will need to reinstall that directory, and\
  718.               perhaps all of Alpha."]} {
  719.             dialog::alert $err
  720.             }
  721.         }
  722.         catch {close $fid}
  723.         }
  724.     }
  725.     
  726.     }
  727.  
  728. }
  729.  
  730.  
  731.  
  732. if {[info tclversion] < 8.0} {
  733.     proc ensureNamespaceExists {cmd} {}
  734.     proc namespace_exists {ns} {
  735.     return [expr {[llength [info commands ${ns}::*]] > 0}]
  736.     }
  737. } else {
  738.     proc ensureNamespaceExists {cmd} {
  739.     set ns ""
  740.     while {[regexp "^((::)?$ns\[a-zA-Z_\]+::)" $cmd ns]} {
  741.         namespace eval $ns {}
  742.     }
  743.     }
  744.     if {[info tclversion] < 8.3} {
  745.     proc namespace_exists {ns} {
  746.         if {![catch {namespace children ::$ns}]} {
  747.         return 1
  748.         } else {
  749.         return 0
  750.         }
  751.     }
  752.     } else {
  753.     # Vince's patch is in Tcl 8.4, so we have 'namespace exists'.
  754.     proc namespace_exists {ns} {
  755.         uplevel 1 [list namespace exists $ns]
  756.     }
  757.     }
  758. }
  759.  
  760. proc alpha::ensureAutoPathOk {} {
  761.     global HOME tcl_platform
  762.     if {[info exists tcl_platform(isWrapped)]} {
  763.     return
  764.     }
  765.     if {![file exists $HOME]} {
  766.     global alpha::platform
  767.     alertnote "Alpha's home directory '$HOME' does not seem to exist. This\
  768.       must be found."
  769.     while {1} {
  770.         if {[catch {get_directory -p "Where is Alpha's home directory"} new_home]} {
  771.         return
  772.         }
  773.         if {[file exists [file join $new_home Tcl]]} {
  774.         set HOME $new_home
  775.         break
  776.         }
  777.         # Probably running on Alphatk
  778.         if {[file exists [file join $new_home Alpha Tcl]]} {
  779.         set HOME [file join $new_home Alpha]
  780.         break
  781.         }
  782.         if {${alpha::platform} == "alpha"} {
  783.         alertnote "That didn't seem to be Alpha's home directory.\
  784.           The home directory must contain the Alpha application and\
  785.           the 'Tcl' subdirectory."
  786.         } else {
  787.         alertnote "That didn't seem to be Alpha's home directory.\
  788.           The home directory must contain alphatk and \
  789.           the 'Alpha' subdirectory."
  790.         }
  791.     }
  792.     # Remove anything which has gone from the auto_path
  793.     set new_auto_path {}
  794.     foreach dir $auto_path {
  795.         if {[file exists $dir]} {
  796.         lappend new_auto_path $dir
  797.         }
  798.     }
  799.     set auto_path $new_auto_path
  800.     unset new_auto_path
  801.     }
  802. }
  803.  
  804. proc alpha::makeAutoPath {{check_dups 1} {skipPrefs 0}} {
  805.     global HOME auto_path
  806.     if {$check_dups} {
  807.     set lcmd lunion
  808.     } else {
  809.     set lcmd lappend
  810.     }
  811.     alpha::ensureAutoPathOk
  812.     set root [file join $HOME Tcl]
  813.     if {![catchNoClobber {file readlink $root} _root]} {
  814.     set root $_root
  815.     }
  816.     
  817.     foreach dir {SystemCode Modes Menus Completions} {
  818.     $lcmd auto_path [file join $root $dir]
  819.     foreach d [glob -types d -nocomplain -dir [file join $root $dir] *] {
  820.         $lcmd auto_path $d
  821.     }
  822.     }
  823.     if {!$skipPrefs} {
  824.     $lcmd auto_path [file join $root Packages]
  825.     $lcmd auto_path [file join $root UserModifications]
  826.     foreach d [glob -types d -nocomplain -dir [file join $root Packages] *] {
  827.         $lcmd auto_path $d
  828.     }
  829.     }
  830. }
  831.  
  832. proc rebuildTclIndices {} {
  833.     global auto_path HOME
  834.     # Make sure nothing weird has happened.
  835.     alpha::ensureAutoPathOk
  836.     foreach dir $auto_path {
  837.     # if directory exists
  838.     if {[file isdirectory $dir]} {
  839.         # if there are any files
  840.         if {![catch {glob -dir $dir *.*tcl} err]} {
  841.         message "Building [file tail $dir] index…"                
  842.         # use 'catch' also in case directory is write-protected
  843.         if {[catch {auto_mkindex $dir *.*tcl} err]} {
  844.             message "Problem rebuilding directory $dir : $err"
  845.         }
  846.         } else {
  847.         message "Directory '$dir' contains no Tcl files!"
  848.         }
  849.     } else {
  850.         message "Directory '$dir' doesn't appear to exist."
  851.     }
  852.     }
  853.     # make alpha forget its old information so the new stuff is loaded
  854.     # when required.
  855.     catch {auto_reset}
  856.     message "Tcl indices rebuilt."
  857. }
  858.  
  859. # 'exit' kills Alpha without allowing it to save etc.
  860. # 'quit' handles a smooth shutdown for us
  861. if {[info commands exit] != ""} {
  862.     rename exit ""
  863.     proc exit {{returnCode ""}} {quit}
  864. }
  865.